perm filename SLOOP2.F4[P11,LCS] blob sn#592326 filedate 1981-06-09 generic text, type T, neo UTF8
C**** SLOOP, SLRS, RNOTE, DRWNT, RDRAW, CIRCLE, RUNTHR
	SUBROUTINE SLOOP
	COMMON/SLR/ SLURX(32)
	COMMON /XRN/RN(1) /PLTR/IPLT,RHT,RDIS 
	COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
	1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
	1 J5,J6,J7,J8,J9,J10,J11,JQ(7),R,RJ
	COMMON/PTR/KWDS(1) /STF/RSTFAC(8),RSTJ2 
	1 /LIMIT/LIMIT,ITEM,L,I,IX /ALF/INP,SLURY(72) 
	IXC=0
	RSEG=L
	SY=L-1
	IHLF=L/2
	RHLF=IHLF
C L  = NUMB OF SEGMENTS IN CURVE.
	RDR=1.0
	RB=RX/SY
	ARX=0
CC	KK=0
CC81	KK=KK+1
CCCC	RA=ARX
CC	SLURX(KK)=ARX*RB+R3
CC	ARX=ARX+1.
CC	IF(KK.LT.L)GO TO 81
	DO 81 K=1,L
	SLURX(K)=ARX+R3
81	ARX=ARX+RB
C BOTTOM OF FIRST LOOP.  FILL IN X COORD.
	RA=-R7*RST7
	LRB=0
	IF(R9.EQ.0)R9=2.8
	R=CENTR-RA
	RK=RHLF
	IF(RJ.GT.0)RK=RSEG
	RNT=RK
CC	RA=-RA
	IF(RJ.GE.200.)IXC=-1
C RJ HAS ABS(R7) >=200 IS RT. 1/2 OF SLUR ONLY.
	IF(R10.LE.0.OR.R10.GE.1.0)GO TO 40
	A2=R10
	IF(R10.GE.0.5)GO TO 440
C R10<>0 SHIFTS CENTER OF CURVATURE.
	IXC=-1
	A2=1.0-R10
440	RNT=RSEG*A2
CC	A0=RSEG-RNT
CC	RDR=RNT/A0
	RDR=RNT/(RSEG-RNT)
	RK=RNT
40	LRB=LRB+1
	A2=RK/RNT
	IF(A2.GE.0.1)GO TO 140
	SLURY(LRB)=R
	GO TO 240
140	RW=RA*A2**R9+R
CC140	RW=RA*A2**ARX+R
	SLURY(LRB)=RW
240	IF(RK.LE.1.0)GO TO 340
	RK=RK-1.0
	GO TO 40
340	IF(RNT.NE.RSEG)GO TO 4
5	IF(RJ.EQ.0)GO TO 15
	IF(IXC.GE.0)GO TO 3
15	KK=1
	LRB=L
	SY=SLURY(IHLF)
CC	IF(JA.EQ.5)GO TO 6
C WHEN IS NEXT USED?
CC	A2=2.*SLURY(IHLF)
CC	A2=A2/RHLF
CC	A1=A2
6	RZ=SLURY(LRB)
CCC	CALL EXCH(RZ,SLURY(KK))
	RZ=SLURY(KK)
	SLURY(KK)=SLURY(LRB)
	IF(RJ.EQ.0)RZ=RZ-2.*(RZ-SY)
CC	IF(RJ.NE.0)GO TO 7
CC	A0=RZ
CC	RZ=2.*(RZ-SY)
C SY=NUM. OF SEGS. IN SLUR
CC	RZ=A0-RZ
CC	IF(JA.EQ.5)GO TO 7
CC	A0=A2*A1
CC	RZ=RZ-A0
CC	A1=A1-1.0
7	SLURY(LRB)=RZ
	IF(KK.EQ.IHLF)GO TO 1
	LRB=LRB-1
	KK=KK+1
	GO TO 6
4	LRZ=L
CC	RB=RDR
	RK=1.0
2	KS=RK
	SLURY(LRZ)=SLURY(KS)
CC	RK=RK+RB
	RK=RK+RDR
	IF(RK.GT.RNT)GO TO 5
	LRZ=LRZ-1
	GO TO 2
CC1	IF(JA.EQ.5)RJ=SLURY(IHLF)
1	RJ=SLURY(IHLF)
3	IF(RTILT.EQ.0)RETURN
	RW=ATAN2(RTILT,RXX)
	RA=SIN(RW)
	RB=COS(RW)
	RZ=SLURX(1)
	RW=SLURY(1)
	DO 83 K=1,L
	R=SLURX(K)-RZ
	ARX=SLURY(K)-RW
	SLURX(K)=RB*R-RA*ARX+RZ
83	SLURY(K)=RB*ARX+RA*R+RW
	END

	SUBROUTINE SLRS
	COMMON R2,JA,CTR,J2,RJQ(20),J3,J4,J5,J6,J7,J8,J9,J10,J11
	COMMON /ALF/INP,SLURY(72) /SLR/SLURX(32)
	K12=J6
	K15=2
	IF(J11.EQ.0)GO TO 22
	K14=0
	K13=1
122	K14=K14+1
	IF(K14.LT.J11)GO TO 22
	K14=0
	K15=K15+K13
	K13=-K13
22	CALL LINES(SLURX(K12),SLURY(K12),K15)
C J11 SETS DASH SIZE. (CURRENTLY =3 SEGMENTS)
	K12=K12+J5
	IF(J5.LT.0)GO TO 322
	IF(K12.GT.J7)RETURN
222	IF(J11.EQ.0)GO TO 22
	GO TO 122
322	IF(K12.GE.J7)GO TO 222
	END

	SUBROUTINE RNOTE(X)
	COMMON /PTR/KWDS(1)/XRN/RN(1)
	K=X
	X=RN(KWDS(MOD(K,1000)))
	END

	SUBROUTINE DRWNT
C [RMINI IS ALF+=49]
	COMMON /STF/RSTFAC(0/7),RSTJ2 /ALF/INP(49),RMINI
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)	
	EQUIVALENCE (J5,JQ(3)),(R6,RJQ(4)),(R5,RJQ(3))
	1,(J7,JQ(5)),(R7,RJQ(5)),(RJZ,RJQ(20)),(R4,RJQ(2))
	1 ,(J9,JQ(7)),(R9,RJQ(7)),(J8,JQ(6)),(R8,RJQ(6))
	RJX=CENTR
	JB=J5
	J8=0
C J8=0  SO IT WILL FILL. (P8 IN 'CLEFS')
	RA=R6
	R6=.5*RMINI/RSTJ2
	R7=R6
	R4=RJZ-3.
	J9=0
	RDR=R8
	R8=0
	CALL CLEFS
	R8=RDR
	J9=R9
C  ↑↑↑↑↑↑ NEEDED??
C  FOR WHITE NOTES AND ACCIS ON PLOTTER.
	CENTR=RJX
	R6=RA
	R7=J7
	J5=R5
	END
C (ALIGNMENT ABOVE IS OFF!)


	SUBROUTINE RDRAW(I,S,XY,X,R3,CENTR,RMINI)
	DIMENSION XY(1)
	DO 2 K=I,IFIX(S)
	L=2
	Y=XY(K)
	IF(Y.LT.1000.)GO TO 3
	L=3
	Y=Y-1000.
C  >1000 = INVIS. LINE
3	M=Y
	Y=(Y-M)*1000.
	IF(Y.GT.100.)Y=100-Y
C  Y NUMBERS .GT.100 ARE NEG.
	B=Y*X+CENTR
	IF(M.GT.60)M=100-M
	A=M*RMINI+R3
2	CALL LINES(A,B,L)
	END

C JA=12  DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
	SUBROUTINE CIRCLE
	COMMON /PLTR/IPLT,RHT,RDIS /STF/RSTFAC(8),RSTJ2 
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(11),L,KQ,K,R,RA,RB 
	EQUIVALENCE (J6,JQ(4)),(R5,RJQ(3)),(J7,JQ(5)),(J8,JQ(6))
	1 ,(R3,RJQ(1))
	RA=5.96*RSTJ2*R5
	RB=J8*RDIS
	IF(J7.LE.J6)J7=J7+360
	KQ=6
C ON DPY DRAW ONLY EVERY 6TH POINT. (DO ALL WHEN IPLT=-1)
	IF(IPLT.LT.0)KQ=1
10	L=3
	DO 3 K=J6,J7,KQ
	R=K
	CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
3	L=2
	RB=RB-1.
	IF(RB.LT.0)RETURN
	RA=RA+1./RDIS
	GO TO 10
	END

C****CALLED FROM MAIN. -- FOR EDITING *******
	SUBROUTINE RUNTHR(M)
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),N,K,A /XRN/RN(1)
	N=RN(M)
	JA=RN(M+1)
	M=M+2
	R2=RN(M)
CC	JUMPGE 6,NONEG	;IF(R2.GE.0)GO TO NONEG
CC	MOVE 6,[4.0]	;CHANGE OLD NEG. STF NUM TO STF4*********
CC	MOVEM 6,(2)	;PUT IT BACK INTO ARRAY
	DO 1 K=1,10
C*** ONLY 12 PARAMETERS USED AT THIS TIME******
	IF(K.GT.N)GO TO 2
	A=RN(M+K)
	RJQ(K)=A
	JQ(K)=A
	GO TO 1
2	RJQ(K)=0
	JQ(K)=0
1	CONTINUE
	M=N+M+1
C SET POINTER AHEAD FOR NEXT ITEM IN RN ARRAY.
	END